home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / gcontext.lisp < prev    next >
Lisp/Scheme  |  1992-06-08  |  41KB  |  968 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; GContext
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;;    GContext values are usually cached locally in the GContext object.
  22. ;;;    This is required because the X.11 server doesn't have any requests
  23. ;;;    for getting GContext values back.
  24. ;;;
  25. ;;;    GContext changes are cached until force-GContext-changes is called.
  26. ;;;    All the requests that use GContext (including the GContext accessors,
  27. ;;;    but not the SETF's) call force-GContext-changes.
  28. ;;;    In addition, the macro WITH-GCONTEXT may be used to provide a 
  29. ;;;    local view if a GContext.
  30. ;;;
  31. ;;;    Each GContext keeps a copy of the values the server has seen, and
  32. ;;;    a copy altered by SETF, called the LOCAL-STATE (bad name...).
  33. ;;;    The SETF accessors increment a timestamp in the GContext.
  34. ;;;    When the timestamp in a GContext isn't equal to the timestamp in
  35. ;;;    the local-state, changes have been made, and force-GContext-changes
  36. ;;;    loops through the GContext and local-state, sending differences to
  37. ;;;    the server, and updating GContext.
  38. ;;;
  39. ;;;    WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
  40. ;;;    a private copy.  This is easy (and fast) for lisp machines, but other
  41. ;;;    lisps will have problems.  Fortunately, most other lisps don't care,
  42. ;;;    because they don't run in a multi-processing shared-address space
  43. ;;;    environment.
  44.  
  45. (in-package :xlib)
  46.  
  47. ;; GContext state accessors
  48. ;;    The state vector contains all card32s to speed server updating
  49.  
  50. (eval-when (eval compile load)
  51.  
  52. (defconstant *gcontext-fast-change-length* #.(length *gcontext-components*))
  53.  
  54. (macrolet ((def-gc-internals (name &rest extras)
  55.         (let ((macros nil)
  56.           (indexes nil)
  57.           (masks nil)
  58.           (index 0))
  59.           (dolist (name *gcontext-components*)
  60.         (push `(defmacro ,(xintern 'gcontext-internal- name) (state)
  61.              `(svref ,state ,,index))
  62.               macros)
  63.         (setf (getf indexes name) index)
  64.         (push (ash 1 index) masks)
  65.         (incf index))
  66.           (dolist (extra extras)
  67.         (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
  68.              `(svref ,state ,,index))
  69.               macros)
  70.         ;; don't override already correct index entries
  71.         (unless (or (getf indexes (second extra)) (getf indexes (first extra)))
  72.           (setf (getf indexes (or (second extra) (first extra))) index))
  73.         (push (logior (ash 1 index)
  74.                   (if (second extra)
  75.                   (ash 1 (position (second extra) *gcontext-components*))
  76.                   0))
  77.               masks)
  78.         (incf index))
  79.           `(within-definition (def-gc-internals ,name)
  80.          ,@(nreverse macros)
  81.          (eval-when (eval compile load)
  82.            (defconstant *gcontext-data-length* ,index)
  83.            (defconstant *gcontext-indexes* ',indexes)
  84.            (defconstant *gcontext-masks*
  85.                 ',(coerce (nreverse masks) 'simple-vector)))))))
  86.   (def-gc-internals ignore
  87.     (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
  88.  
  89. ) ;; end EVAL-WHEN
  90.  
  91. (deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
  92.  
  93. (deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
  94.  
  95. (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
  96.   (name nil :type symbol :read-only t)
  97.   (default nil :type t :read-only t)
  98.   (set-function #'identity :type (function (gcontext t) t) :read-only t)
  99.   (copy-function #'identity :type (function (gcontext gcontext t) t) :read-only t))
  100.  
  101. (defvar *gcontext-extensions* nil) ;; list of gcontext-extension
  102.  
  103. ;; Gcontext state Resource
  104. (defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
  105.  
  106. (defmacro gcontext-state-next (state)
  107.   `(svref ,state 0))
  108.  
  109. (defun allocate-gcontext-state ()
  110.   ;; Allocate a gcontext-state
  111.   ;; Loop until a local state is found that's large enough to hold
  112.   ;; any extensions that may exist.
  113.   (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
  114.     (declare (type array-index length))
  115.     (loop
  116.       (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
  117.                         gcontext-state-next gcontext-state)
  118.                (make-array length :initial-element nil))))
  119.     (declare (type gcontext-state state))
  120.     (when (index>= (length state) length)
  121.       (return state))))))
  122.  
  123. (defun deallocate-gcontext-state (state)
  124.   (declare (type gcontext-state state))
  125.   (fill state nil)
  126.   (threaded-atomic-push state *gcontext-local-state-cache*
  127.             gcontext-state-next gcontext-state))
  128.  
  129. ;; Temp-Gcontext Resource
  130. (defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
  131.  
  132. (defun allocate-temp-gcontext ()
  133.   (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
  134.       (make-gcontext :local-state '#() :server-state '#())))
  135.  
  136. (defun deallocate-temp-gcontext (gc)
  137.   (declare (type gcontext gc))
  138.   (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
  139.  
  140. ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
  141. ;; as (type <type> <name>), there is an accessor:
  142.  
  143. ;(defun gcontext-<name> (gcontext)
  144. ;  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
  145. ;  ;; off, or the component was copied from a gcontext with unknown state).
  146. ;  (declare (type gcontext gcontext)
  147. ;       (values <type>)))
  148.  
  149. ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
  150. ;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
  151.  
  152. ;(defsetf gcontext-<name> (gcontext) (value)
  153. ;  )
  154.  
  155. ;; Generate all the accessors and defsetf's for GContext
  156.  
  157. (defmacro xgcmask->gcmask (mask)
  158.   `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*)))))
  159.  
  160. (defmacro access-gcontext ((gcontext local-state) &body body)
  161.   `(let ((,local-state (gcontext-local-state ,gcontext)))
  162.      (declare (type gcontext-state ,local-state))
  163.      ,@body))
  164.  
  165. (defmacro modify-gcontext ((gcontext local-state) &body body)
  166.   ;; The timestamp must be altered after the modification
  167.   `(let ((,local-state (gcontext-local-state ,gcontext)))
  168.      (declare (type gcontext-state ,local-state))
  169.      (prog1
  170.      (progn ,@body)
  171.        (setf (gcontext-internal-timestamp ,local-state) 0))))
  172.  
  173. (defmacro def-gc-accessor (name type)
  174.   (let* ((gcontext-name (xintern 'gcontext- name))
  175.      (internal-accessor (xintern 'gcontext-internal- name))
  176.      (internal-setfer (xintern 'set- gcontext-name)))
  177.     `(within-definition (,name def-gc-accessor)
  178.  
  179.        (defun ,gcontext-name (gcontext)
  180.      (declare (type gcontext gcontext))
  181.      (declare (values (or null ,type)))
  182.      (let ((value (,internal-accessor (gcontext-local-state gcontext))))
  183.        (declare (type (or null card32) value))
  184.        (when value ;; Don't do anything when value isn't known
  185.          (let ((%buffer (gcontext-display gcontext)))
  186.            (declare (type display %buffer))
  187.            %buffer
  188.            (decode-type ,type value)))))
  189.        
  190.        (defun ,internal-setfer (gcontext value)
  191.      (declare (type gcontext gcontext)
  192.           (type ,type value))
  193.      (modify-gcontext (gcontext local-state)
  194.        (setf (,internal-accessor local-state) (encode-type ,type value))
  195.        ,@(when (eq type 'pixmap)
  196.            ;; write-through pixmaps, because the protocol allows
  197.            ;; the server to copy the pixmap contents at the time
  198.            ;; of the store, rather than continuing to share with
  199.            ;; the pixmap.
  200.            `((let ((server-state (gcontext-server-state gcontext)))
  201.            (setf (,internal-accessor server-state) nil))))
  202.        value))
  203.        
  204.        (defsetf ,gcontext-name ,internal-setfer))))
  205.  
  206. (defmacro incf-internal-timestamp (state)
  207.   (let ((ts (gensym)))
  208.     `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
  209.        (declare (type fixnum ,ts))
  210.        ;; the probability seems low enough
  211.        (setq ,ts (if (= ,ts most-positive-fixnum)
  212.              1
  213.              (the fixnum (1+ ,ts))))
  214.        (setf (gcontext-internal-timestamp ,state) ,ts))))
  215.  
  216. (def-gc-accessor function boole-constant)
  217. (def-gc-accessor plane-mask card32)
  218. (def-gc-accessor foreground card32)
  219. (def-gc-accessor background card32)
  220. (def-gc-accessor line-width card16)
  221. (def-gc-accessor line-style (member :solid :dash :double-dash))
  222. (def-gc-accessor cap-style (member :not-last :butt :round :projecting))
  223. (def-gc-accessor join-style (member :miter :round :bevel))
  224. (def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
  225. (def-gc-accessor fill-rule (member :even-odd :winding))
  226. (def-gc-accessor tile pixmap)
  227. (def-gc-accessor stipple pixmap)
  228. (def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
  229. (def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
  230. ;; (def-GC-accessor font font) ;; See below
  231. (def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
  232. (def-gc-accessor exposures (member :off :on))
  233. (def-gc-accessor clip-x int16)
  234. (def-gc-accessor clip-y int16)
  235. ;; (def-GC-accessor clip-mask) ;; see below
  236. (def-gc-accessor dash-offset card16)
  237. ;; (def-GC-accessor dashes)  ;; see below
  238. (def-gc-accessor arc-mode (member :chord :pie-slice))
  239.  
  240.  
  241. (defun gcontext-clip-mask (gcontext)
  242.   (declare (type gcontext gcontext))
  243.   (declare (values (or null (member :none) pixmap rect-seq)
  244.            (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
  245.   (access-gcontext (gcontext local-state)
  246.     (multiple-value-bind (clip clip-mask)
  247.     (without-interrupts
  248.       (values (gcontext-internal-clip local-state)
  249.           (gcontext-internal-clip-mask local-state)))
  250.       (if (null clip)
  251.       (values (let ((%buffer (gcontext-display gcontext)))
  252.             (declare (type display %buffer))
  253.             (decode-type (or (member :none) pixmap) clip-mask))
  254.           nil)
  255.     (values (second clip)
  256.         (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
  257.                  (first clip)))))))
  258.  
  259. (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
  260.   ;; A bit strange, but retains setf form.
  261.   ;; a nil clip-mask is transformed to an empty vector
  262.   `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
  263.  
  264. (defun set-gcontext-clip-mask (gcontext ordering clip-mask)
  265.   ;; a nil clip-mask is transformed to an empty vector
  266.   (declare (type gcontext gcontext)
  267.        (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
  268.        (type (or (member :none) pixmap rect-seq) clip-mask))
  269.   (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
  270.   (multiple-value-bind (clip-mask clip)
  271.       (typecase clip-mask
  272.     (pixmap (values (pixmap-id clip-mask) nil))
  273.     ((member :none) (values 0 nil))
  274.     (sequence
  275.       (values nil
  276.           (list (encode-type
  277.               (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
  278.               ordering)
  279.             (copy-seq clip-mask))))
  280.     (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
  281.     (modify-gcontext (gcontext local-state)
  282.       (let ((server-state (gcontext-server-state gcontext)))
  283.     (declare (type gcontext-state server-state))
  284.     (without-interrupts
  285.       (setf (gcontext-internal-clip local-state) clip
  286.         (gcontext-internal-clip-mask local-state) clip-mask)
  287.       (if (null clip)
  288.           (setf (gcontext-internal-clip server-state) nil)
  289.         (setf (gcontext-internal-clip-mask server-state) nil))
  290.       (when (and clip-mask (not (zerop clip-mask)))
  291.         ;; write-through clip-mask pixmap, because the protocol allows the
  292.         ;; server to copy the pixmap contents at the time of the store,
  293.         ;; rather than continuing to share with the pixmap.
  294.         (setf (gcontext-internal-clip-mask server-state) nil))))))
  295.   clip-mask)
  296.  
  297. (defun gcontext-dashes (gcontext)
  298.   (declare (type gcontext gcontext))
  299.   (declare (values (or null card8 sequence)))
  300.   (access-gcontext (gcontext local-state)
  301.     (multiple-value-bind (dash dashes)
  302.     (without-interrupts 
  303.       (values (gcontext-internal-dash local-state)
  304.           (gcontext-internal-dashes local-state)))
  305.       (if (null dash)
  306.       dashes
  307.     dash))))
  308.  
  309. (defsetf gcontext-dashes set-gcontext-dashes)
  310.  
  311. (defun set-gcontext-dashes (gcontext dashes)
  312.   (declare (type gcontext gcontext)
  313.        (type (or card8 sequence) dashes))
  314.   (multiple-value-bind (dashes dash)
  315.       (if (type? dashes 'sequence)
  316.       (if (zerop (length dashes))
  317.           (x-type-error dashes '(or card8 sequence) "non-empty sequence")
  318.         (values nil (or (copy-seq dashes) (vector))))
  319.     (values (encode-type card8 dashes) nil))
  320.     (modify-gcontext (gcontext local-state)
  321.       (let ((server-state (gcontext-server-state gcontext)))
  322.     (declare (type gcontext-state server-state))
  323.     (without-interrupts
  324.       (setf (gcontext-internal-dash local-state) dash
  325.         (gcontext-internal-dashes local-state) dashes)
  326.       (if (null dash)
  327.           (setf (gcontext-internal-dash server-state) nil)
  328.         (setf (gcontext-internal-dashes server-state) nil))))))
  329.   dashes)
  330.  
  331. (defun gcontext-font (gcontext &optional metrics-p)
  332.   ;; If the stored font is known, it is returned.  If it is not known and
  333.   ;; metrics-p is false, then nil is returned.  If it is not known and
  334.   ;; metrics-p is true, then a pseudo font is returned.  Full metric and
  335.   ;; property information can be obtained, but the font does not have a name or
  336.   ;; a resource-id, and attempts to use it where a resource-id is required will
  337.   ;; result in an invalid-font error.
  338.   (declare (type gcontext gcontext)
  339.        (type boolean metrics-p))
  340.   (declare (values (or null font)))
  341.   (access-gcontext (gcontext local-state)
  342.     (let ((font (gcontext-internal-font-obj local-state)))
  343.       (or font
  344.       (when metrics-p
  345.         ;; XXX this isn't correct
  346.         (make-font :display (gcontext-display gcontext)
  347.                :id (gcontext-id gcontext)
  348.                :name nil))))))
  349.  
  350. (defsetf gcontext-font set-gcontext-font)
  351.  
  352. (defun set-gcontext-font (gcontext font)
  353.   (declare (type gcontext gcontext)
  354.        (type fontable font))
  355.   (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
  356.      (font (and font-object (font-id font-object))))
  357.     ;; XXX need to check font has id (and name?)
  358.     (modify-gcontext (gcontext local-state)
  359.       (let ((server-state (gcontext-server-state gcontext)))
  360.     (declare (type gcontext-state server-state))
  361.     (without-interrupts
  362.       (setf (gcontext-internal-font-obj local-state) font-object
  363.         (gcontext-internal-font local-state) font)
  364.       ;; check against font, not against font-obj
  365.       (if (null font)
  366.           (setf (gcontext-internal-font server-state) nil)
  367.         (setf (gcontext-internal-font-obj server-state) font-object))))))
  368.   font)
  369.  
  370. (defun force-gcontext-changes-internal (gcontext)
  371.   ;; Force any delayed changes.
  372.   (declare (type gcontext gcontext))
  373.   #.(declare-buffun)
  374.  
  375.   (let ((display (gcontext-display gcontext))
  376.     (server-state (gcontext-server-state gcontext))
  377.     (local-state (gcontext-local-state gcontext)))
  378.     (declare (type display display)
  379.          (type gcontext-state server-state local-state))
  380.  
  381.     ;; Update server when timestamps don't match
  382.     (unless (= (the fixnum (gcontext-internal-timestamp local-state))
  383.            (the fixnum (gcontext-internal-timestamp server-state)))
  384.  
  385.       ;; The display is already locked.
  386.       (macrolet ((with-buffer ((buffer &key timeout) &body body)
  387.            `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
  388.                ,@body)))
  389.  
  390.     ;; Because there is no locking on the local state we have to
  391.     ;; assume that state will change and set timestamps up front,
  392.     ;; otherwise by the time we figured out there were no changes
  393.     ;; and tried to store the server stamp as the local stamp, the
  394.     ;; local stamp might have since been modified.
  395.     (setf (gcontext-internal-timestamp local-state)
  396.           (incf-internal-timestamp server-state))
  397.  
  398.     (block no-changes
  399.       (let ((last-request (buffer-last-request display)))
  400.         (with-buffer-request (display *x-changegc*)
  401.           (gcontext gcontext)
  402.           (progn
  403.         (do ((i 0 (index+ i 1))
  404.              (bit 1 (the xgcmask (ash bit 1)))
  405.              (nbyte 12)
  406.              (mask 0)
  407.              (local 0))
  408.             ((index>= i *gcontext-fast-change-length*)
  409.              (when (zerop mask)
  410.                ;; If nothing changed, restore last-request and quit
  411.                (setf (buffer-last-request display)
  412.                  (if (zerop (buffer-last-request display))
  413.                  nil
  414.                    last-request))
  415.                (return-from no-changes nil))
  416.              (card29-put 8 mask)
  417.              (card16-put 2 (index-ash nbyte -2))
  418.              (index-incf (buffer-boffset display) nbyte))
  419.           (declare (type array-index i nbyte)
  420.                (type xgcmask bit)
  421.                (type gcmask mask)
  422.                (type (or null card32) local))
  423.           (unless (eql (the (or null card32) (svref server-state i))
  424.                    (setq local (the (or null card32) (svref local-state i))))
  425.             (setf (svref server-state i) local)
  426.             (card32-put nbyte local)
  427.             (setq mask (the gcmask (logior mask bit)))
  428.             (index-incf nbyte 4)))))))
  429.  
  430.     ;; Update GContext extensions
  431.     (do ((extension *gcontext-extensions* (cdr extension))
  432.          (i *gcontext-data-length* (index+ i 1))
  433.          (local))
  434.         ((endp extension))
  435.       (unless (eql (svref server-state i)
  436.                (setq local (svref local-state i)))
  437.         (setf (svref server-state i) local)
  438.         (funcall (gcontext-extension-set-function (car extension)) gcontext local)))
  439.  
  440.     ;; Update clipping rectangles
  441.     (multiple-value-bind (local-clip server-clip)
  442.         (without-interrupts 
  443.           (values (gcontext-internal-clip local-state)
  444.               (gcontext-internal-clip server-state)))
  445.       (unless (equalp local-clip server-clip)
  446.         (setf (gcontext-internal-clip server-state) nil)
  447.         (unless (null local-clip)
  448.           (with-buffer-request (display *x-setcliprectangles*)
  449.         (data (first local-clip))
  450.         (gcontext gcontext)
  451.         ;; XXX treat nil correctly
  452.         (card16 (or (gcontext-internal-clip-x local-state) 0)
  453.             (or (gcontext-internal-clip-y local-state) 0))
  454.         ;; XXX this has both int16 and card16 values
  455.         ((sequence :format int16) (second local-clip)))
  456.           (setf (gcontext-internal-clip server-state) local-clip))))
  457.  
  458.     ;; Update dashes
  459.     (multiple-value-bind (local-dash server-dash)
  460.         (without-interrupts 
  461.           (values (gcontext-internal-dash local-state)
  462.               (gcontext-internal-dash server-state)))
  463.       (unless (equalp local-dash server-dash)
  464.         (setf (gcontext-internal-dash server-state) nil)
  465.         (unless (null local-dash)
  466.           (with-buffer-request (display *x-setdashes*)
  467.         (gcontext gcontext)
  468.         ;; XXX treat nil correctly
  469.         (card16 (or (gcontext-internal-dash-offset local-state) 0)
  470.             (length local-dash))
  471.         ((sequence :format card8) local-dash))
  472.           (setf (gcontext-internal-dash server-state) local-dash))))))))
  473.  
  474. (defun force-gcontext-changes (gcontext)
  475.   ;; Force any delayed changes.
  476.   (declare (type gcontext gcontext))
  477.   (let ((display (gcontext-display gcontext))
  478.     (server-state (gcontext-server-state gcontext))
  479.     (local-state (gcontext-local-state gcontext)))
  480.     (declare (type gcontext-state server-state local-state)
  481.          (array-register server-state local-state))
  482.     ;; Update server when timestamps don't match
  483.     (unless (= (the fixnum (gcontext-internal-timestamp local-state))
  484.            (the fixnum (gcontext-internal-timestamp server-state)))
  485.       (with-display (display)
  486.     (force-gcontext-changes-internal gcontext)))))
  487.  
  488. ;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
  489. ;;;         SET IN THE GCONTEXT ON ENTRY.  BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
  490. ;;;         UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
  491. ;;;         COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
  492. ;;;          BACK.
  493.  
  494. (defmacro with-gcontext ((gcontext &rest options &key clip-ordering
  495.                    &allow-other-keys)
  496.              &body body)
  497.   ;; "Binds" the gcontext components specified by options within the
  498.   ;; dynamic scope of the body (i.e., indefinite scope and dynamic
  499.   ;; extent), on a per-process basis in a multi-process environment.
  500.   ;; The body is not surrounded by a with-display.  If cache-p is nil or
  501.   ;; the some component states are unknown, this will implement
  502.   ;; save/restore by creating a temporary gcontext and doing
  503.   ;; copy-gcontext-components to and from it.
  504.  
  505.   (declare (arglist (gcontext &rest options &key
  506.                  function plane-mask foreground background
  507.                  line-width line-style cap-style join-style
  508.                  fill-style fill-rule arc-mode tile stipple ts-x
  509.                  ts-y font subwindow-mode exposures clip-x clip-y
  510.                  clip-mask clip-ordering dash-offset dashes
  511.                  &allow-other-keys)
  512.            &body body))
  513.   (remf options :clip-ordering)
  514.  
  515.   (let ((gc (gensym))
  516.     (saved-state (gensym))
  517.     (temp-gc (gensym))
  518.     (temp-mask (gensym))
  519.     (temp-vars nil)
  520.     (setfs nil)
  521.     (indexes nil) ; List of gcontext field indices
  522.     (extension-indexes nil) ; List of gcontext extension field indices
  523.     (ts-index (getf *gcontext-indexes* :timestamp)))
  524.  
  525.     (do* ((option options (cddr option))
  526.       (name (car option) (car option))
  527.       (value (cadr option) (cadr option)))
  528.      ((endp option) (setq setfs (nreverse setfs)))
  529.       (let ((index (getf *gcontext-indexes* name)))
  530.     (if index
  531.         (push index indexes)
  532.       (let ((extension (find name *gcontext-extensions*
  533.                  :key #'gcontext-extension-name)))
  534.         (if extension
  535.         (progn
  536.           (push (xintern "Internal-" 'gcontext- name "-State-Index")
  537.             extension-indexes))
  538.           (x-type-error name 'gcontext-key)))))
  539.       (let ((accessor `(,(xintern 'gcontext- name) ,gc
  540.             ,@(when (eq name :clip-mask) `(,clip-ordering))))
  541.         (temp-var (gensym)))
  542.     (when value
  543.       (push `(,temp-var ,value) temp-vars)
  544.       (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs))))
  545.     (if setfs
  546.     `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
  547.          (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
  548.        (declare (type gcontext ,gc)
  549.             (type gcontext-state ,saved-state)
  550.             (type xgcmask ,temp-mask)
  551.             (type (or null gcontext) ,temp-gc))
  552.        (with-gcontext-bindings (,gc ,saved-state
  553.                     ,(append indexes extension-indexes)
  554.                     ,ts-index ,temp-mask ,temp-gc)
  555.          (let ,temp-vars
  556.            ,@setfs)
  557.          ,@body))
  558.       `(progn ,@body))))
  559.  
  560. (defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
  561.   ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
  562.   (declare (type gcontext gcontext)
  563.        (type list indexes)
  564.        (dynamic-extent extension-indices))
  565.   (let ((local-state (gcontext-local-state gcontext))
  566.     (saved-state (allocate-gcontext-state))
  567.     (cache-p (gcontext-cache-p gcontext)))
  568.     (declare (type gcontext-state local-state saved-state))
  569.     (setf (gcontext-internal-timestamp saved-state) 1)
  570.     (let ((temp-gc nil)
  571.       (temp-mask 0)
  572.       (extension-mask 0))
  573.       (declare (type xgcmask temp-mask)
  574.            (type integer extension-mask))
  575.       (dolist (i indexes)
  576.     (when (or (not (setf (svref saved-state i) (svref local-state i)))
  577.           (not cache-p))
  578.       (setq temp-mask
  579.         (the xgcmask (logior temp-mask
  580.                      (the xgcmask (svref *gcontext-masks* i)))))))
  581.       (dolist (i extension-indices)
  582.     (when (or (not (setf (svref saved-state i) (svref local-state i)))
  583.           (not cache-p))
  584.       (setq extension-mask
  585.         (the xgcmask (logior extension-mask (ash 1 i))))))
  586.       (when (or (plusp temp-mask)
  587.         (plusp extension-mask))
  588.     ;; Copy to temporary GC when field unknown or cache-p false
  589.     (let ((display (gcontext-display gcontext)))
  590.       (declare (type display display))
  591.       (with-display (display)
  592.         (setq temp-gc (allocate-temp-gcontext))
  593.         (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
  594.           (gcontext-display temp-gc) display
  595.           (gcontext-drawable temp-gc) (gcontext-drawable gcontext)
  596.           (gcontext-server-state temp-gc) saved-state
  597.           (gcontext-local-state temp-gc) saved-state)
  598.         ;; Create a new (temporary) gcontext
  599.         (with-buffer-request (display *x-creategc*)
  600.           (gcontext temp-gc)
  601.           (drawable (gcontext-drawable gcontext))
  602.           (card29 0))
  603.         ;; Copy changed components to the temporary gcontext
  604.         (when (plusp temp-mask)
  605.           (with-buffer-request (display *x-copygc*)
  606.         (gcontext gcontext)
  607.         (gcontext temp-gc)
  608.         (card29 (xgcmask->gcmask temp-mask))))
  609.         ;; Copy extension fields to the new gcontext
  610.         (when (plusp extension-mask)
  611.           ;; Copy extension fields from temp back to gcontext
  612.           (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
  613.            (i 0 (index+ i 1)))
  614.           ((zerop bit))
  615.         (let ((copy-function (gcontext-extension-copy-function
  616.                        (elt *gcontext-extensions* i))))
  617.           (funcall copy-function gcontext temp-gc
  618.                (svref local-state (index+ i *gcontext-data-length*))))))
  619.         )))
  620.       (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) 
  621.  
  622. (defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
  623.   (declare (type gcontext gcontext temp-gc)
  624.        (type xgcmask temp-mask))
  625.   (let ((display (gcontext-display gcontext)))
  626.     (declare (type display display))
  627.     (with-display (display)
  628.       (with-buffer-request (display *x-copygc*)
  629.     (gcontext temp-gc)
  630.     (gcontext gcontext)
  631.     (card29 (xgcmask->gcmask temp-mask)))
  632.       ;; Copy extension fields from temp back to gcontext
  633.       (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
  634.        (extensions *gcontext-extensions* (cdr extensions))
  635.        (i *gcontext-data-length* (index+ i 1))
  636.        (local-state (gcontext-local-state temp-gc)))
  637.       ((zerop bit))
  638.     (let ((copy-function (gcontext-extension-copy-function (car extensions))))
  639.       (funcall copy-function temp-gc gcontext (svref local-state i))))
  640.       ;; free gcontext
  641.       (with-buffer-request (display *x-freegc*)
  642.     (gcontext temp-gc))
  643.       (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
  644.       (deallocate-temp-gcontext temp-gc)
  645.       ;; Copy saved state back to server state
  646.       (do ((server-state (gcontext-server-state gcontext))
  647.        (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
  648.        (i 0 (index+ i 1)))
  649.       ((zerop bit)
  650.        (incf-internal-timestamp server-state))
  651.     (declare (type gcontext-state server-state)
  652.          (type gcmask bit)
  653.          (type array-index i))
  654.     (when (oddp bit)
  655.       (setf (svref server-state i) nil))))))
  656.  
  657. (defun create-gcontext (&rest options &key (drawable (required-arg drawable))
  658.             function plane-mask foreground background
  659.             line-width line-style cap-style join-style fill-style fill-rule
  660.             arc-mode tile stipple ts-x ts-y font subwindow-mode
  661.             exposures clip-x clip-y clip-mask clip-ordering
  662.             dash-offset dashes
  663.             (cache-p t)
  664.             &allow-other-keys)
  665.   ;; Only non-nil components are passed on in the request, but for effective caching
  666.   ;; assumptions have to be made about what the actual protocol defaults are.  For
  667.   ;; all gcontext components, a value of nil causes the default gcontext value to be
  668.   ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
  669.   ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
  670.   ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
  671.   ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
  672.   ;; component will have no effect unless the new value differs from the cached
  673.   ;; value.  Component changes (setfs and with-gcontext) are always deferred
  674.   ;; regardless of the cache mode, and sent over the protocol only when required by a
  675.   ;; local operation or by an explicit call to force-gcontext-changes.
  676.   (declare (type drawable drawable) ; Required to be non-null
  677.        (type (or null boole-constant) function)
  678.        (type (or null pixel) plane-mask foreground background)
  679.        (type (or null card16) line-width dash-offset)
  680.        (type (or null int16) ts-x ts-y clip-x clip-y)
  681.        (type (or null (member :solid :dash :double-dash)) line-style)
  682.        (type (or null (member :not-last :butt :round :projecting)) cap-style)
  683.        (type (or null (member :miter :round :bevel)) join-style)
  684.        (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
  685.        (type (or null (member :even-odd :winding)) fill-rule)
  686.        (type (or null (member :chord :pie-slice)) arc-mode)
  687.        (type (or null pixmap) tile stipple)
  688.        (type (or null fontable) font)
  689.        (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
  690.        (type (or null (member :on :off)) exposures)
  691.        (type (or null (member :none) pixmap rect-seq) clip-mask)
  692.        (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
  693.        (type (or null card8 sequence) dashes)
  694.        (dynamic-extent options)
  695.        (type boolean cache-p))
  696.   (declare (values gcontext))
  697.   (let* ((display (drawable-display drawable))
  698.      (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
  699.      (local-state (gcontext-local-state gcontext))
  700.      (server-state (gcontext-server-state gcontext))
  701.      (gcontextid (allocate-resource-id display gcontext 'gcontext)))
  702.     (declare (type display display)
  703.          (type gcontext gcontext)
  704.          (type resource-id gcontextid)
  705.          (type gcontext-state local-state server-state))
  706.     (setf (gcontext-id gcontext) gcontextid)
  707.  
  708.     (unless function (setf (gcontext-function gcontext) boole-1))
  709.     ;; using the depth of the drawable would be better, but ...
  710.     (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
  711.     (unless foreground (setf (gcontext-foreground gcontext) 0))
  712.     (unless background (setf (gcontext-background gcontext) 1))
  713.     (unless line-width (setf (gcontext-line-width gcontext) 0))
  714.     (unless line-style (setf (gcontext-line-style gcontext) :solid))
  715.     (unless cap-style (setf (gcontext-cap-style gcontext) :butt))
  716.     (unless join-style (setf (gcontext-join-style gcontext) :miter))
  717.     (unless fill-style (setf (gcontext-fill-style gcontext) :solid))
  718.     (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
  719.     (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
  720.     (unless ts-x (setf (gcontext-ts-x gcontext) 0))
  721.     (unless ts-y (setf (gcontext-ts-y gcontext) 0))
  722.     (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
  723.                  :clip-by-children))
  724.     (unless exposures (setf (gcontext-exposures gcontext) :on))
  725.     (unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
  726.     (unless clip-x (setf (gcontext-clip-x gcontext) 0))
  727.     (unless clip-y (setf (gcontext-clip-y gcontext) 0))
  728.     (unless dashes (setf (gcontext-dashes gcontext) 4))
  729.     (unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
  730.     ;; a bit kludgy, but ...
  731.     (replace server-state local-state)
  732.  
  733.     (when function (setf (gcontext-function gcontext) function))
  734.     (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
  735.     (when foreground (setf (gcontext-foreground gcontext) foreground))
  736.     (when background (setf (gcontext-background gcontext) background))
  737.     (when line-width (setf (gcontext-line-width gcontext) line-width))
  738.     (when line-style (setf (gcontext-line-style gcontext) line-style))
  739.     (when cap-style (setf (gcontext-cap-style gcontext) cap-style))
  740.     (when join-style (setf (gcontext-join-style gcontext) join-style))
  741.     (when fill-style (setf (gcontext-fill-style gcontext) fill-style))
  742.     (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
  743.     (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
  744.     (when tile (setf (gcontext-tile gcontext) tile))
  745.     (when stipple (setf (gcontext-stipple gcontext) stipple))
  746.     (when ts-x (setf (gcontext-ts-x gcontext) ts-x))
  747.     (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
  748.     (when font (setf (gcontext-font gcontext) font))
  749.     (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
  750.     (when exposures (setf (gcontext-exposures gcontext) exposures))
  751.     (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
  752.     (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
  753.     (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
  754.     (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
  755.     (when dashes (setf (gcontext-dashes gcontext) dashes))
  756.     
  757.     (setf (gcontext-internal-timestamp server-state) 1)
  758.     (setf (gcontext-internal-timestamp local-state)
  759.       ;; SetClipRectangles or SetDashes request need to be sent?
  760.       (if (or (gcontext-internal-clip local-state)
  761.           (gcontext-internal-dash local-state))
  762.           ;; Yes, mark local state "modified" to ensure
  763.           ;; force-gcontext-changes will occur.
  764.           0
  765.         ;; No, mark local state "unmodified"
  766.         1))
  767.     
  768.     (with-buffer-request (display *x-creategc*)
  769.       (resource-id gcontextid)
  770.       (drawable drawable)
  771.       (progn (do* ((i 0 (index+ i 1))
  772.            (bit 1 (the xgcmask (ash bit 1)))
  773.            (nbyte 16)
  774.            (mask 0)
  775.            (local (svref local-state i) (svref local-state i)))
  776.          ((index>= i *gcontext-fast-change-length*)
  777.           (card29-put 12 mask)
  778.           (card16-put 2 (index-ash nbyte -2))
  779.           (index-incf (buffer-boffset display) nbyte))
  780.            (declare (type array-index i nbyte)
  781.             (type xgcmask bit)
  782.             (type gcmask mask)
  783.             (type (or null card32) local))
  784.            (unless (eql local (the (or null card32) (svref server-state i)))
  785.          (setf (svref server-state i) local)
  786.          (card32-put nbyte local)
  787.          (setq mask (the gcmask (logior mask bit)))
  788.          (index-incf nbyte 4)))))
  789.  
  790.     ;; Initialize extensions
  791.     (do ((extensions *gcontext-extensions* (cdr extensions))
  792.      (i *gcontext-data-length* (index+ i 1)))
  793.     ((endp extensions))
  794.       (declare (type list extensions)
  795.            (type array-index i))
  796.       (setf (svref server-state i)
  797.         (setf (svref local-state i)
  798.           (gcontext-extension-default (car extensions)))))
  799.  
  800.     ;; Set extension values
  801.     (do* ((option-list options (cddr option-list))
  802.       (option (car option-list) (car option-list))
  803.       (extension))
  804.      ((endp option-list))
  805.       (declare (type list option-list))
  806.       (cond ((getf *gcontext-indexes* option))    ; Gcontext field
  807.         ((member option '(:drawable :clip-ordering :cache-p)))    ; Optional parameter
  808.         ((setq extension (find option *gcontext-extensions*
  809.                    :key #'gcontext-extension-name))
  810.          (funcall (gcontext-extension-set-function extension)
  811.               gcontext (second option-list)))
  812.         (t (x-type-error option 'gcontext-key))))
  813.     gcontext)) 
  814.  
  815. (defun copy-gcontext-components (src dst &rest keys)
  816.   (declare (type gcontext src dst)
  817.        (dynamic-extent keys))
  818.   ;; you might ask why this isn't just a bunch of
  819.   ;;   (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
  820.   ;; the answer is that you can do that yourself if you want, what we are
  821.   ;; providing here is access to the protocol request, which will generally
  822.   ;; be more efficient (particularly for things like clip and dash lists).
  823.   (when keys
  824.     (let ((display (gcontext-display src))
  825.       (mask 0))
  826.       (declare (type xgcmask mask))
  827.       (with-display (display)
  828.     (force-gcontext-changes-internal src)
  829.     (force-gcontext-changes-internal dst)
  830.     
  831.     ;; collect entire mask and handle extensions
  832.     (dolist (key keys)
  833.       (let ((i (getf *gcontext-indexes* key)))
  834.         (declare (type (or null array-index) i))
  835.         (if i
  836.         (setq mask (the xgcmask (logior mask
  837.                         (the xgcmask (svref *gcontext-masks* i)))))
  838.           (multiple-value-bind (extension index)
  839.           (find key *gcontext-extensions* :key #'gcontext-extension-name)
  840.         (if extension
  841.             (funcall (gcontext-extension-copy-function extension)
  842.                  src dst (svref (gcontext-local-state src)
  843.                         (index+ index *gcontext-data-length*)))
  844.           (x-type-error key 'gcontext-key))))))
  845.     
  846.     (when (plusp mask)
  847.       (do ((src-server-state (gcontext-server-state src))
  848.            (dst-server-state (gcontext-server-state dst))
  849.            (dst-local-state (gcontext-local-state dst))
  850.            (bit mask (the xgcmask (ash bit -1)))
  851.            (i 0 (index+ i 1)))
  852.           ((zerop bit)
  853.            (incf-internal-timestamp dst-server-state)
  854.            (setf (gcontext-internal-timestamp dst-local-state) 0))
  855.         (declare (type gcontext-state src-server-state dst-server-state dst-local-state)
  856.              (type xgcmask bit)
  857.              (type array-index i))
  858.         (when (oddp bit)
  859.           (setf (svref dst-local-state i)
  860.             (setf (svref dst-server-state i) (svref src-server-state i)))))
  861.       (with-buffer-request (display *x-copygc*)
  862.         (gcontext src dst)
  863.         (card29 (xgcmask->gcmask mask))))))))
  864.  
  865. (defun copy-gcontext (src dst)
  866.   (declare (type gcontext src dst))
  867.   ;; Copies all components.
  868.   (apply #'copy-gcontext-components src dst *gcontext-components*)
  869.   (do ((extensions *gcontext-extensions* (cdr extensions))
  870.        (i *gcontext-data-length* (index+ i 1)))
  871.       ((endp extensions))
  872.     (funcall (gcontext-extension-copy-function (car extensions))
  873.          src dst (svref (gcontext-local-state src) i))))
  874.        
  875. (defun free-gcontext (gcontext)
  876.   (declare (type gcontext gcontext))
  877.   (let ((display (gcontext-display gcontext)))
  878.     (with-buffer-request (display *x-freegc*)
  879.       (gcontext gcontext))
  880.     (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
  881.     (deallocate-gcontext-state (gcontext-server-state gcontext))
  882.     (deallocate-gcontext-state (gcontext-local-state gcontext))
  883.     nil))
  884.  
  885. (defmacro define-gcontext-accessor (name &key default set-function copy-function)
  886.   ;; This will define a new gcontext accessor called NAME.
  887.   ;; Defines the gcontext-NAME accessor function and its defsetf.
  888.   ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
  889.   ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
  890.   ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
  891.   ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
  892.   ;; from create-gcontext, and force-gcontext-changes.
  893.   ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
  894.   ;; from copy-gcontext and copy-gcontext-components.
  895.   ;; The copy-function defaults to:
  896.   ;; (lambda (ignore dst-gc value)
  897.   ;;    (if value
  898.   ;;        (,set-function dst-gc value)
  899.   ;;      (error "Can't copy unknown GContext component ~a" ',name)))
  900.   (declare (type symbol name)
  901.        (type t default)
  902.        (type (function (gcontext t) t) set-function) ;; required
  903.        (type (or null (function (gcontext gcontext t) t))
  904.          copy-function))
  905.   (let* ((gc-name (intern (concatenate 'string
  906.                        (string 'gcontext-)
  907.                        (string name)))) ;; in current package
  908.      (key-name (kintern name))
  909.      (setfer (xintern "Set-" gc-name))
  910.      (internal-set-function (xintern "Internal-Set-" gc-name))
  911.      (internal-copy-function (xintern "Internal-Copy-" gc-name))
  912.      (internal-state-index (xintern "Internal-" gc-name "-State-Index")))
  913.     (unless copy-function
  914.       (setq copy-function
  915.         `(lambda (src-gc dst-gc value)
  916.            (declare (ignore src-gc))
  917.            (if value
  918.            (,set-function dst-gc value)
  919.          (error "Can't copy unknown GContext component ~a" ',name)))))
  920.     `(progn
  921.        (eval-when (compile load eval)
  922.      (defparameter ,internal-state-index
  923.                (add-gcontext-extension ',key-name ,default ',internal-set-function
  924.                            ',internal-copy-function))
  925.      ) ;; end eval-when
  926.        (defun ,gc-name (gcontext)
  927.      (svref (gcontext-local-state gcontext) ,internal-state-index))
  928.        (defun ,setfer (gcontext new-value)
  929.      (let ((local-state (gcontext-local-state gcontext)))
  930.        (setf (gcontext-internal-timestamp local-state) 0)
  931.        (setf (svref local-state ,internal-state-index) new-value)))
  932.        (defsetf ,gc-name ,setfer)
  933.        (defun ,internal-set-function (gcontext new-value)
  934.      (,set-function gcontext new-value)
  935.      (setf (svref (gcontext-server-state gcontext) ,internal-state-index)
  936.            (setf (svref (gcontext-local-state gcontext) ,internal-state-index)
  937.              new-value)))
  938.        (defun ,internal-copy-function (src-gc dst-gc new-value)
  939.      (,copy-function src-gc dst-gc new-value)
  940.      (setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
  941.            (setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
  942.              new-value)))
  943.        ',name)))
  944.  
  945. ;; GContext extension fields are treated in much the same way as normal GContext
  946. ;; components.  The current value is stored in a slot of the gcontext-local-state,
  947. ;; and the value known to the server is in a slot of the gcontext-server-state.
  948. ;; The slot-number is defined by its position in the *gcontext-extensions* list.
  949. ;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is 
  950. ;; the extension component name) reflects this position.  The position within
  951. ;; *gcontext-extensions* and the value of the special value are determined at
  952. ;; LOAD time to facilitate merging of seperately compiled extension files.
  953.  
  954. (defun add-gcontext-extension (name default-value set-function copy-function)
  955.   (declare (type symbol name)
  956.        (type t default-value)
  957.        (type (function (gcontext t) t) set-function)
  958.        (type (function (gcontext gcontext t) t) copy-function))
  959.   (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
  960.             (prog1 (length *gcontext-extensions*)
  961.                (push nil *gcontext-extensions*)))))
  962.     (setf (nth number *gcontext-extensions*)
  963.       (make-gcontext-extension :name name
  964.                    :default default-value
  965.                    :set-function set-function
  966.                    :copy-function copy-function))
  967.     (+ number *gcontext-data-length*)))
  968.